Personal Computer World 2007 September/PCWSEP07.iso/Software/Linux/Linux Mint 3.0 Light/LinuxMint-3.0-Light.iso/casper/filesystem.squashfs/usr/share/festival/tobi_rules.scm

Text File | 2006-12-20 | 34.6 KB | 1,003 lines

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                       ;;
;;;                Centre for Speech Technology Research                  ;;
;;;                     University of Edinburgh, UK                       ;;
;;;                       Copyright (c) 1996,1997                         ;;
;;;                        All Rights Reserved.                           ;;
;;;                                                                       ;;
;;;  Permission is hereby granted, free of charge, to use and distribute  ;;
;;;  this software and its documentation without restriction, including   ;;
;;;  without limitation the rights to use, copy, modify, merge, publish,  ;;
;;;  distribute, sublicense, and/or sell copies of this work, and to      ;;
;;;  permit persons to whom this work is furnished to do so, subject to   ;;
;;;  the following conditions:                                            ;;
;;;   1. The code must retain the above copyright notice, this list of    ;;
;;;      conditions and the following disclaimer.                         ;;
;;;   2. Any modifications must be clearly marked as such.                ;;
;;;   3. Original authors' names are not deleted.                         ;;
;;;   4. The authors' names are not used to endorse or promote products   ;;
;;;      derived from this software without specific prior written        ;;
;;;      permission.                                                      ;;
;;;                                                                       ;;
;;;  THE UNIVERSITY OF EDINBURGH AND THE CONTRIBUTORS TO THIS WORK        ;;
;;;  DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING      ;;
;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT   ;;
;;;  SHALL THE UNIVERSITY OF EDINBURGH NOR THE CONTRIBUTORS BE LIABLE     ;;
;;;  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES    ;;
;;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN   ;;
;;;  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,          ;;
;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF       ;;
;;;  THIS SOFTWARE.                                                       ;;
;;;                                                                       ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                Authors: Robert A. J. Clark and Alan W Black
;;;                Modifications and Checking:
;;;                         Gregor Moehler ([e-mail])
;;;                         Matthew Stone ([e-mail])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Generate F0 points from tobi labels using rules given in:
;;; Jilka, Moehler & Dogil (forthcomming in Speech Communications)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  *** Converted to new Relation architecture -- but not checked yet -- awb
;;;      -> crude (beta) checking: gm in Dec. 98
;;;
;;;      -> fixed TAKEOVER bug that used time value
;;;         as pitch target (!) - MDS 1/02
;;;      -> hacked around bunches of target overlap problems - MDS 1/02
;;;      -> added primitive pitch range controls
;;;
;;;  Known problems and bugs:
;;;      Can't currently use voicing intervals which cross syllable boundaries,
;;;      so pre/post-nuclear tones are currently places 0.2s before/after the
;;;      nuclear tone even if no voicing occurs. Failing this they default a
;;;      percentage of the voicing for that syllable.
;;;
;;;      Don't know about target points ahead of the current syllable.
;;;      (As you need to know what comes before them to calculate them)
;;;      So: post accent tones are placed 0.2 ahead if following syllable exists
;;;          ends before 0.2 from starred target and is not accented
;;;      The H-target of the H+!H* is 0.2 sec instead of 0.15 sec before
;;;      starred tone.
;;;
;;;      Multi-utterance input has not been tested.
;;;
;;;      !H- does not generate any targets
;;;
;;;      Unfortunaltely some other modules may decide to put pauses in the
;;;      middle of a phrase
;;;
;;;      valleys are not tested yet
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  To use this in a voice
;;;     (require 'tobi_rules)
;;;  And in the voice call
;;;     (setup_tobi_f0_method)
;;;  Set the following for your speaker's F0 range
;;;  (Parameter.set 'Default_Topline 146)
;;;  (Parameter.set 'Default_Start_Baseline 61)
;;;  (Parameter.set 'Valley_Dip 75)

;; level of debug printout
(set! printdebug 0)

(define (setup_tobi_f0_method)
  "(setup_tobi_f0_method)
Set up parameters for current voice to use the implementaion
of ToBI labels to F0 targets by rule."
  (Parameter.set 'Int_Method Intonation_Tree)
  (Parameter.set 'Int_Target_Method Int_Targets_General)
  (set! int_accent_cart_tree no_int_cart_tree) ; NONE always
  (set! int_tone_cart_tree   no_int_cart_tree) ; NONE always
  (set! int_general_params
    (list
     (list 'targ_func tobi_f0_targets)))   ; we will return a list of f0 targets here

  (Parameter.set 'Phrase_Method 'cart_tree)
  (set! phrase_cart_tree tobi_label_phrase_cart_tree) ; redefines the phrasebreak tree
  t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;
;;;;;; Define and set the new f0 rules
;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Set global parameters
;;; You may want to reset these for different speakers

(Parameter.set 'Default_Topline 146) ;146
(Parameter.set 'Default_Start_Baseline 61) ;61
(Parameter.set 'Current_Topline        (Parameter.get 'Default_Topline))
(Parameter.set 'Current_Start_Baseline (Parameter.get 'Default_Start_Baseline))
(Parameter.set 'Current_End_Baseline   (Parameter.get 'Current_Start_Baseline))
(Parameter.set 'Downstep_Factor 0.70)
(Parameter.set 'Valley_Dip 75)
;;; function to add target points on a given syllable and fill in
;;; targets where necessary

(define (tobi_f0_targets utt syl)
  "(tobi_f0_targets UTT ITEM)
   Returns a list of targets for the given syllable."
  (if (and (>= printdebug  1)
       (not(equal? 0 (item.feat syl "R:Intonation.daughter1.name"))))
      (format t "### %l (%.2f %.2f) %l ptarg: %l ###\n" (item.name syl)
          (item.feat syl "syllable_start")(item.feat syl "syllable_end")
          (item.feat syl "R:Intonation.daughter1.name") (ttt_last_target_time syl)))

  ;; only continue if there is a Word related to this syllable
  ;; I know there always should be, but there might be a bug elsewhere
  (cond
   ((not(equal? 0 (item.feat syl "R:SylStructure.parent.name")))

    ; get current label. This assumes that there is only one accent and
    ; one endtone on a syllable. Although there can be one of each.
    (let ((voicing  (ttt_get_voice_times syl))                ; voicing interval
      (pvoicing (ttt_get_voice_times                      ; previous voicing
             (item.relation.prev syl 'Syllable)))
      (nvoicing (ttt_get_voice_times                      ; next voicing
             (item.relation.next syl 'Syllable))))

    ; if first syl of phrase set Phrase_Start and Phrase_End parameters
    ; and reset downstep (currently does so on big and little breaks.)
    ; only assignes Default values at this stage
    ; maybe trained from CART later - first steps now - MDS
    ; following Moehler and Mayer, SSW 2001
    (if   (eq 0 (item.feat syl 'syl_in)) ;; GM maybe something better needed here?
    (progn
     (Parameter.set 'Phrase_Start (item.feat syl 'R:SylStructure.parent.R:Phrase.last.word_start))
     (Parameter.set 'Phrase_End (item.feat syl 'R:SylStructure.parent.R:Phrase.last.word_end))
     (Parameter.set 'Current_Topline
            (/ (* (wagon syl ttt_topline_tree)
                  (Parameter.get 'Default_Topline)) 100))
     (Parameter.set 'Current_Start_Baseline
            (/ (* (wagon syl ttt_baseline_tree)
                  (Parameter.get 'Default_Start_Baseline)) 100))
     (Parameter.set 'Current_End_Baseline
            (Parameter.get 'Current_Start_Baseline))
     (if (>= printdebug  3)
         (begin
           (print (format nil "new range: %f %f %f"
                  (Parameter.get 'Current_Topline)
                  (Parameter.get 'Current_Start_Baseline)
                  (Parameter.get 'Current_End_Baseline) ))))  ))

    ; do stuff (should go only if there is an accent/boundary?)
    (let ((new_targets
       (ttt_to_targets syl (wagon syl ttt_starttone_tree)
               voicing
               pvoicing
               nvoicing
               'Starttones)))

    (set! new_targets (append new_targets
       (ttt_to_targets syl (wagon syl ttt_accent_tree)
               voicing
               pvoicing
               nvoicing
               'Accents)))

    (set! new_targets (append new_targets
       (ttt_to_targets syl (wagon syl ttt_endtone_tree)
               voicing
               pvoicing
               nvoicing
               'Endtones)))

    (if (and(not(equal? new_targets nil))
        (>= printdebug  2))
    (begin
      (format t ">> Targets: %l\n" new_targets)
      (format t ">> LastTarget: %l\n" (last new_targets))
      ))

      new_targets)))))


;;; CART tree to specify no accents

(set! no_int_cart_tree
'
((NONE)))

;;;
;;; Relate phrasing to boundary tones.
;;;   Added downstepped tones - MDS

(set! tobi_label_phrase_cart_tree
'
((tone in ("L-" "H-" "!H-"))
 ((B))
 ((tone in ("H-H%" "H-L%" "!H-L%" "L-L%" "L-H%"))
  ((BB))
  ((NB)))))

;;;
;;;  The other functions
;;;

;;; process a list of relative targets and convert to actual targets

(define (ttt_to_targets syl rlist voicing pvoicing nvoicing type)
  "Takes a list of target sets and returns a list of targets."
  (if (or (and (>= printdebug  2)
           rlist (atom (caar rlist))
           (not (equal? 'NONE (caar rlist))) (not (equal? '(NONE) (caar rlist))))
      (>= printdebug  3))
       (begin (print "Entering ttt_to_targets with:")
    (print (format nil "rlist: %l vc: %l pvc: %l nvc: %l type: %s" rlist voicing pvoicing nvoicing type))))
(cond
 ;; nowt
 ((eq (length rlist) 0) ())
 ;; a single target set
 ((atom (car (car rlist)))
  (cond
   ((eq type 'Accents)
    (ttt_accent_set_to_targets syl rlist voicing pvoicing nvoicing))
   ((eq type 'Starttones)
    (ttt_bound_set_to_targets syl rlist voicing pvoicing))
   ((eq type 'Endtones)
    (ttt_bound_set_to_targets syl rlist voicing pvoicing))
   (t (error "unknown target set encountered in ttt_to_targets"))))
 ;; list of target sets
 ((atom (car (car (car rlist))))
  (append (ttt_to_targets syl (cdr rlist) voicing pvoicing nvoicing type)
      (ttt_to_targets syl (car rlist) voicing pvoicing nvoicing type)))
 ;; error
 (t (error "something strange has happened in ttt_to_targets"))))


;; process a starttone/endtone target set.

(define (ttt_bound_set_to_targets syl tset voicing pvoicing)
  "takes a start/endtone target set and returns a list of target points."
  (if (>= printdebug  3) (begin
      (print "Entering ttt_bound_set_to_targets with:")
      (pprintf (format nil "tset: %l vc: %l pvc: %l" tset voicing pvoicing))))
  (cond
   ;; usually target given is NONE. (also ignore unknown!)
   ((or (eq (car (car tset)) 'NONE)
    (eq (car (car tset)) 'UNKNOWN))
    nil)
   ;; a pair of target pairs
   ((eq (length tset) 2)
    (list (ttt_get_target (car tset) voicing)
      (ttt_get_target (car (cdr tset)) voicing)))
   ;; single target pair
   ((eq (length tset) 1)
    (cond
     ;; an actual target pair
     ((not (null (cdr (car tset))))
      (list (ttt_get_target (car tset) voicing)))
     ;; a TAKEOVER marker
     ((eq (car (car tset)) 'TAKEOVER)
      (list (list (ttt_interval_percent voicing 0)
          (ttt_last_target_value syl))))
     (t (error "unknown target pair in ttt_bound_set_to_targets"))))
   (t (error "unknown target set type in ttt_bound_set_to_targets"))))


;; process an accent target set.

(define (ttt_accent_set_to_targets syl tset voicing pvoicing nvoicing)
  "takes a accent target set and returns a list of target points."
  (if (>= printdebug  3) (begin
      (print "Entering ttt_accent_set_to_targets with:")
      (pprintf (format nil "tset: %l vc: %l pvc: %l nvc: %l" tset voicing pvoicing nvoicing))))
  (cond
   ;; single target in set
   ((null (cdr tset))
    (cond
     ; target given is NONE.
     ((or (eq (car (car tset)) 'NONE)
      (eq (car (car tset)) 'UNKNOWN)) nil)
     ; V1 marker
     ((eq (car (car tset)) 'V1)
      (let ((target_time (+ (/ (- (next_accent_start syl)
                  (ttt_last_target_time syl))
                   2.0)
                (ttt_last_target_time syl))))
    (list (list target_time (ttt_accent_pitch (Parameter.get 'Valley_Dip) target_time)))))
     ; V2 marker
     ((eq (car (car tset)) 'V2)
      (let ((target_time (+ (ttt_last_target_time syl) 0.25)))
    (list (list target_time (ttt_accent_pitch (Parameter.get 'Valley_Dip) target_time)))))
     ; V3 marker
     ((eq (car (car tset)) 'V3)
      (let ((target_time (- (next_accent_start syl) 0.25)))
    (list (list target_time (ttt_accent_pitch (Parameter.get 'Valley_Dip) target_time)))))
     ; single target pair
     (t (list (ttt_get_target (car tset) voicing)))))
   ;; a pair of targets
   ((length tset 2)
    (cond
     ;; a *ed tone with PRE type tone (as in L+H*)
     ((eq (car (car tset)) 'PRE)
      (let ((star_target (ttt_get_target (car (cdr tset)) voicing))
        (last_target (parse-number(ttt_last_target_time syl))))
    (cond
     ; normal 0.2s case (currently doesn't check for voicing)
     ((and (eqv? 0 (ip_initial syl))
           (> (- (car star_target) 0.2) last_target))
      (list  (list (- (car star_target) 0.2)
                  (ttt_accent_pitch (car (cdr (car tset)))
                     (- (car star_target) 0.2))) ; the time
            star_target))

     ; 90% prev voiced if not before last target - Added back in MDS,
     ; with parse-number added and new check for ip_initial
     ((and (eqv? 0 (ip_initial syl))
           (> (parse-number (ttt_interval_percent pvoicing 90))
          (parse-number (ttt_last_target_time syl))))
      (list (list (ttt_interval_percent pvoicing 90)
              (ttt_accent_pitch (car (cdr (car tset)))
                    (ttt_interval_percent pvoicing 90)))
        star_target))

     ;  otherwise (UNTESTED) [NOTE: Voicing for this syllable only]
     (t
      (list (list (ttt_interval_percent voicing 20)
             (ttt_accent_pitch (car (cdr (car tset)))
                       (ttt_interval_percent voicing 20)))
           star_target)))))
     ; a *ed tone with POST type tone (as L*+H)
     ((eq (car(car(cdr tset))) 'POST)
      (let ((star_target (ttt_get_target (car tset) voicing))
        (next_target nil ) ; interesting problem
        (next_syl (item.next syl)))

    (cond
     ; normal 0.2s case (UNTESTED)
     ((and (not (equal? next_syl nil))
           (eq 0 (item.feat next_syl "accented")))
      (cond
       ((< (+ (car star_target) 0.2) (item.feat next_syl "syllable_end"))
        (list star_target
          (list (+ (car star_target) 0.2)
            (ttt_accent_pitch (car (cdr (car (cdr tset))))
                      (+ (car star_target) 0.2) ))))
       (t

        (list star_target
            (list (ttt_interval_percent nvoicing 90)
              (ttt_accent_pitch (car (cdr (car (cdr tset))))
                        (ttt_interval_percent nvoicing 90) ))))))

     ; 20% next voiced (BUG: Can't do this as the next target hasn't been
     ;                                                     calculated yet!)
     (nil nil)
     ;otherwise (UNTESTED)
     (t (list star_target
          (list (ttt_interval_percent voicing 90)
            (ttt_accent_pitch (car (cdr (car (cdr tset))))
                      (ttt_interval_percent voicing 90) )))))))

     (t
      ;; This case didn't use to happen, but now must
      ;; to avoid +H's clobbering endtones - MDS's hack.
      (list (ttt_get_target (car tset) voicing)
        (ttt_get_target (cadr tset) voicing)))))


   ;; something else...
   (t (error (format nil "unknown accent set in ttt_accent_set_to_targets: %l" tset)))))



(define (ttt_get_target pair voicing)
  "Returns actual target pair, usually for a stared tone."
  (if (>= printdebug  4) (begin
      (print "Entering ttt_get_target with:")
      (pprintf pair) (pprintf voicing)))
  (list (ttt_interval_percent voicing (car pair))
    (ttt_accent_pitch (car (cdr pair))
              (ttt_interval_percent voicing (car pair)))))

(define (ttt_accent_pitch value time)
  "Converts a accent pitch entry to a pitch value."
  (if (>= printdebug  4) (begin
      (print "Entering ttt_accent_pitch with:")
      (pprintf value)))
  (cond
   ;; a real value
   ((number? value)
    (ttt_interval_percent (list (ttt_get_current_baseline time)
                (Parameter.get 'Current_Topline))
              value))
   ;; Downstep then Topline
   ((eq value 'DHIGH)
    (progn
     (Parameter.set 'Current_Topline (+ (ttt_get_current_baseline time)
                    (* (Parameter.get 'Downstep_Factor)
                       (- (Parameter.get 'Current_Topline)
                          (ttt_get_current_baseline time)))))
     (ttt_interval_percent (list (ttt_get_current_baseline time)
                 (Parameter.get 'Current_Topline))
               100)))

   ;; Unknown
   (t  (error "Unknown accent pitch value encountered"))))


(define (ttt_get_current_baseline v)
  "Returns the current declined baseline at time v."
  (if (>= printdebug  4) (begin
      (print "Entering  ttt_get_current_baseline with:")
      (pprintf v)))
  (let ((h (Parameter.get 'Current_Start_Baseline))
    (l (Parameter.get 'Current_End_Baseline))
    (e (Parameter.get 'Phrase_End))
    (s (Parameter.get 'Phrase_Start)))
    (- h (* (/ (- h l) (- e s)) (- v s)))))

;;; find the time n% through an inteval

(define (ttt_interval_percent pair percent)
  "Returns the time that is percent percent thought the pair."
  (if (>= printdebug  4) (begin
      (print "Entering ttt_interval_percent with:")
      (pprintf (format nil "%l, %l" pair percent))))
  (cond
   ; no pair given: just return nil
   ((null pair) nil)
   ; otherwise do the calculation
   (t (let ((start (car pair))
        (end (car(cdr pair))))
    (+ start (* (- end start) (/ percent 100)))))))


;;;  Getting start and end voicing times in a syllable

(define (ttt_get_voice_times syl_item)
  "Returns a pair of start time of first voiced phone in syllable and
end of last voiced phone in syllable, or nil if syllable is nil"
  (cond
   ((null syl_item) nil)
   (t (let ((segs (item.relation.daughters syl_item "SylStructure")))
    (list
     (item.feat (ttt_first_voiced segs) "segment_start")
     (item.feat (ttt_first_voiced (reverse segs)) "end"))))))

(define (ttt_first_voiced segs)
  "Returns first segment that is voiced (vowel or voiced consonant)
returns last segment if all are unvoiced."
  (cond
   ((null (cdr segs))
    (car segs))  ;; last possibility
   ((equal? "+" (item.feat (car segs) "ph_vc"))
    (car segs))
   ((equal? "+" (item.feat (car segs) "ph_cvox"))
    (car segs))
   (t
    (ttt_first_voiced (cdr segs)))))

;;; ttt_last_target has bifurcated into
;;;   ttt_last_target_time and
;;;   ttt_last_target_value
;;; to fix a place where f0 was set to last target time!
;;;   - MDS

(define (ttt_last_target_time syl)
  "Returns the end of the most recent previous target
in the utterance or nil if there is not one present
"
  (if (>= printdebug  3)
      (begin (print "Entering  ttt_last_target_time")
         (print syl))
      )
  (let ((target (ttt_last_target syl)))
    (if (null? target)
    nil
    (item.feat target "R:Target.daughter1.pos"))))

(define (ttt_last_target_value syl)
  "Returns the pitch of the most recent previous target
in the utterance or nil if there is not one present
"
  (if (>= printdebug  3)
      (begin (print "Entering  ttt_last_target_time")
         (print syl))
      )
  (let ((target (ttt_last_target syl)))
    (if (null? target)
    nil
    (item.feat target "R:Target.daughter1.f0"))))

;; Changed to scan through segments in the segment relation,
;; to catch (notional) targets on pauses.  - MDS
;;
;;; associated segments are:
;;; - the segments in the word
;;; - subsequent segments not in the syllable structure
;;; and on the first word, preceding segments
;;; not in the syllable structure

(define (ttt_collect_following seg accum)
  (if (or (null? seg)
      (not (null? (item.relation seg 'SylStructure))))
      accum
      (ttt_collect_following (item.next seg)
                 (cons seg accum))))


(define (ttt_last_target syl)
  "Returns the most recent previous target
in the utterance or nil if there is not one present
"
(if (>= printdebug  3)
    (begin (print "Entering  ttt_last_target")
    (print syl))
    )
  (let ((prev_syl (item.relation.prev syl 'Syllable)))
    (cond
;     ((symbol-bound? 'new_targets) (last (caar new_targets)))
     ((null prev_syl) nil)
     ((ttt_last_target_segs
       (ttt_collect_following
    (item.relation.next
     (item.relation.daughtern prev_syl "SylStructure")
     "Segment")
    (reverse (item.relation.daughters prev_syl "SylStructure")))))
                    ;list of segments of prev. syllable
                    ;in reverse order, with pauses
                    ;prepended.
     (t (ttt_last_target prev_syl)))))

(define (ttt_last_target_segs segs)
  "Returns the first target no earlier than seg
or nil if there is not one
"
(if (>= printdebug  4)
    (begin (print "Entering  ttt_last_target_segs with:")
       (pprintf (format nil "%l" segs))
))
  (cond
   ((null segs) nil)
   ((and  (> (parse-number
          (item.feat  (car segs) "R:Target.daughter1.f0")) 0)
      (eq 0 (item.feat (car segs) "R:SylStructure.parent.lisp_lh_condition"))
      (eq 0 (item.feat (car segs) "R:SylStructure.parent.lisp_hl_condition"))
      (eq 0 (item.feat (car segs) "R:SylStructure.parent.lisp_valley_condition")))
    (car segs))

   (t (ttt_last_target_segs (cdr segs)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;
;;;;;; CART TREES                           (ttt - tobi to target)
;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;
;;; Return a list of target lists. A target list comprises of a list
;;; of related targets (ie for the L and H in L+H*), just to confuse
;;; matters each target is also a list! (pos pitch)
;;;


(set! ttt_endtone_tree  ; BUG: does it check the current syl for last accent?
      '
      ((tobi_endtone is NONE)        ; ususally none
       ((((NONE))))
       ((tobi_endtone is "H-H%")     ; H-H%
    ((((100 120))))
    ((tobi_endtone is "L-L%")    ; L-L%
     ((((100 -20))))
     ((tobi_endtone is "L-H%")   ; L-H%
      ((lisp_last_accent > 2)
       ((lisp_last_accent_type is "L*")
        ((((0 25) (100 40))))    ; paper says 80 but AWB had 40
        ((((0 0) (100 40)))))
       ((lisp_last_accent_type is "L*")
        ((((100 40))))
        ((((50 0) (100 40))))))
      ((tobi_endtone is "H-L%")  ; H-L%
       ((lisp_last_accent_type is "L*")
        ((tobi_accent is"L*")
         ((((50 100) (100 100))))
         ((((0 100) (100 100)))))
        ((((100 100)))))
      ((tobi_endtone is "!H-L%")  ; !H-L%
       ((lisp_last_accent_type is "L*")
        ((tobi_accent is"L*")
         ((((50 DHIGH) (100 100))))
         ((((0 DHIGH) (100 100)))))
        ((((100 DHIGH)))))
       ((tobi_endtone is "H-")
        ((((100 100))))
        ((tobi_endtone is "!H-")
         ((((100 DHIGH))))
         ((tobi_endtone is "L-")
          ((((100 0))))
          ((((UNKNOWN))))))))))))))

(set! ttt_starttone_tree
      '
      ((lisp_ip_initial = 1)
       ((tobi_endtone is "%H")
    ((((0 100))))
    ((p.tobi_endtone in ("H-" "!H-" "L-"))
     ((((TAKEOVER))))       ; takeover case
     ((tobi_accent is NONE)
      ((lisp_next_accent > 2) ; default cases  (dep. on whether next target is low)
       ((lisp_next_accent_type in ("L*" "L*+H" "L*+!H" "L+H*" "L+!H*" "L-" "L-H%" "L-L%"))
        ((((0 50)(100 25))))
        ((((0 50)(100 75)))))
       ((lisp_next_accent_type in ("L*" "L*+H" "L*+!H" "L+H*" "L+!H*" "L-" "L-H%" "L-L%"))
        ((((0 30))))
        ((((0 70))))))
      ((tobi_accent in ("L*" "L*+H" "L*+!H" "L+H*" "L+!H*" "L-" "L-H%" "L-L%"))
        ((((0 30))))
        ((((0 70))))))))
       ((((NONE))))))     ; otherwise (and usually) nothing.

;; Redone after Jilka, Moehler and Dogil
;; - But treating one-syllable-ip's like
;; last-syllable-of-ip's in cases of
;; two tone switches per syllable (e.g. H* L-H%).
;; - And (hack) a 70% target for the initial
;; H*'s of phrases when the next accent is L+H*
;; - MDS

(set! ttt_accent_tree
      '
      ((tobi_accent is "H*" )    ; H*
       ((lisp_ip_final = 1)
    ((lisp_ip_one_syllable_case = 1)
     ((((50 100))))
     ((((25 100)))))
    ((lisp_hstar_weak_target = 1)
     ((((60 70))))
     ((lisp_ip_initial = 1)
      ((((85 100))))
      ((((60 100)))))))

      ((tobi_accent is "!H*" )    ; !H*
       ((lisp_ip_final = 1)
    ((lisp_ip_one_syllable_case = 1)
     ((((50 DHIGH))))
     ((((25 DHIGH)))))
       ((lisp_ip_initial = 1)
    ((((85 DHIGH))))
    ((((60 DHIGH))))))

    ((tobi_accent is "L*" )    ; L*
     ((lisp_ip_final = 1)
      ((lisp_ip_one_syllable_case = 1)
       ((((50 0))))
       ((((25 0)))))
      ((lisp_ip_initial = 1)
       ((((85 0))))
       ((((60 0))))))

    ((tobi_accent is "L+H*")   ; L+H*
     ((lisp_ip_final = 1)
      ((lisp_ip_one_syllable_case = 1)
       ((((PRE 20) (50 100))))  ; JMD estimated 70
       ((((PRE 20) (25 100)))))
      ((lisp_ip_initial = 1)
       ((((PRE 20) (90 100))))
       ((((PRE 20) (75 100))))))

     ((tobi_accent is "L+!H*")   ; L+!H*
     ((lisp_ip_final = 1)
      ((lisp_ip_one_syllable_case = 1)
       ((((PRE 20) (70 DHIGH))))
       ((((PRE 20) (25 DHIGH)))))
      ((lisp_ip_initial = 1)
       ((((PRE 20) (90 DHIGH))))
       ((((PRE 20) (75 DHIGH))))))

      ((tobi_accent is "L*+H")   ; L*+H
       ((lisp_ip_final = 1)
        ((lisp_ip_one_syllable_case = 1)
         ((((35 0) (80 100))))     ; POST would clobber endtones
         ((((15 0) (40 100)))))    ; POST would clobber endtones - MDS
        ((lisp_ip_initial = 1)
         ((((55 0) (POST 100))))
         ((((40 0) (POST 100))))))

      ((tobi_accent is "L*+!H")   ; L*+!H
       ((lisp_ip_final = 1)
        ((lisp_ip_one_syllable_case = 1)
         ((((35 0) (80 DHIGH))))    ; POST would clobber endtones - MDS
         ((((15 0) (40 DHIGH)))))   ; POST would clobber endtones - MDS
        ((lisp_ip_initial = 1)
         ((((55 0) (POST DHIGH))))
         ((((40 0) (POST DHIGH))))))

       ((tobi_accent is "H+!H*")    ; H+!H*
        ((lisp_ip_final = 1)
         ((lisp_ip_one_syllable_case = 1)
          ((((PRE 143) (60 DHIGH)))) ; the 143 is a hack to level out the downstep
          ((((PRE 143) (20 DHIGH)))))
         ((lisp_ip_initial = 1)
          ((((PRE 143) (90 DHIGH))))
          ((((PRE 143) (60 DHIGH))))))

        ((lisp_lh_condition = 1)
         ((((100 75))))
         ((lisp_lh_condition = 2)
          ((((0 90))))
          ((lisp_hl_condition = 1)
           ((((100 25))))
           ((lisp_valley_condition = 1)
        ((((V1 85))))
        ((lisp_valley_condition = 2)
         ((((V2 70))))
         ((lisp_valley_condition = 3)
          ((((V3 70))))
          ((tobi_accent is NONE)   ; usually we find no accent
           ((((NONE))))
           ((((UNKNOWN))))))))))))))))))))     ; UNKNOWN TARGET FOUND

;;; Cart tree to "predict" pitch range
;;; Right now just accesses a feature
;;; "register" following Moehler & Mayer 2001.
;;; Register must be one of
;;;   H    - primary high register (default): 133% lowest, 92% highest
;;;   H-H  - expanded high register: 134% lowest, 100% highest
;;;   H-L  - lowered high register: 128% lowest, 87% highest
;;;   L    - primary low register: 100% lowest, 73% highest
;;;   L-L  and HL-L - low compressed: 100% lowest, 66% highest
;;;   HL   - expanded register:   100% lowest, 84% highest
;;;   HL-H - complete register:   100% lowest, 96% highest
;;; For their speaker, ,BASELINE was 42% of PEAK

(set! ttt_topline_tree
      '
      ((R:SylStructure.parent.register is "H")
       (92)
       ((R:SylStructure.parent.register is "H-H")
    (100)
    ((R:SylStructure.parent.register is "H-L")
     (87)
     ((R:SylStructure.parent.register is "L")
      (73)
      ((R:SylStructure.parent.register is "L-L")
       (66)
       ((R:SylStructure.parent.register is "HL")
        (84)
        ((R:SylStructure.parent.register is "HL-H")
         (96)
         (92)))))))))

(set! ttt_baseline_tree
      '
      ((R:SylStructure.parent.register is "H")
       (133)
       ((R:SylStructure.parent.register is "H-H")
    (134)
    ((R:SylStructure.parent.register is "H-L")
     (128)
     ((R:SylStructure.parent.register is "L")
      (100)
      ((R:SylStructure.parent.register is "L-L")
       (100)
       ((R:SylStructure.parent.register is "HL")
        (100)
        ((R:SylStructure.parent.register is "HL-H")
         (100)
         (133)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;
;;;;;;   Lisp Feature functions.
;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (valley_condition syl)
"(valley_condition syl)
Function to determine if a lowered target between two high target points
is needed in this syllable.
Returns:  0 - no target required
          1 - the single target case
          2 - the first of the two target case
          3 - the second of the two target case
"
(if (>= printdebug  4)
    (begin (print "Entering valley_condition")))
(cond
 ((and (eq 0 (item.feat syl 'accented))
       (string-matches (next_accent_type syl)
               "\\(H\\*\\|H\\-\\|H\\-L\\%\\|H\\-H\\%\\|\\!H\\*\\|\\!H\\-\\|\\!H\\-L\\%\\|\\!H\\-H\\%\\)")
       (string-matches (last_accent_type syl)
               "\\(H\\*\\|L\\+H\\*\\|L\\*\\+H\\\\|\\!H\\*\\|L\\+\\!H\\*\\|L\\*\\+\\!H\\)"))
                       ;GM: excluded %H (returns nil for last target)
  (let ((nas (next_accent_start syl))
    (syls (item.feat syl 'syllable_start))
    (syle (item.feat syl 'syllable_end))
    (las (ttt_last_target_time syl)))
    (if (>= printdebug  3)
    (begin (print (format nil "nas: %l syls: %l syle %l las %l" nas syls syle las))))
    (cond
     ((and (< (- nas las) 0.5)
       (> (- nas las) 0.25)
       (< syls (+ (/ (- nas las) 2.0) (ttt_last_target_time syl)))
       (> syle (+ (/ (- nas las) 2.0) (ttt_last_target_time syl)))) 1)
     ((and (> (- nas las) 0.5)
       (< syls (+ (ttt_last_target_time syl) 0.25))
       (> syle (+ (ttt_last_target_time syl) 0.25))) 2)
     ((and (> (- nas las) 0.5)
       (< syls (- nas 0.25))
       (> syle (- nas 0.25))) 3)
     (t 0))))
 (t 0)))



(define (lh_condition syl)
"(lh_condition syl)
Function to determine the need for extra target points between an L and an H
Returns: 1 - first extra target required
         2 - second extra target required
         0 - no target required.
"
(if (>= printdebug  4)
    (begin (print "Entering LH_condition")))
(cond
 ((and (eq 0 (item.feat syl 'accented))
       (string-matches (last_accent_type syl) "\\(L\\*\\)")
       (string-matches (next_accent_type syl)
               "\\(H\\*\\|H\\-\\|H\\-L\\%\\|H\\-H\\%\\)"))
  (cond
   ((and (eq 1 (last_accent syl))
     (< 2 (next_accent syl))) 1)
   ((and (< 2 (last_accent syl))
     (eq 1 (next_accent syl))) 2)
   (t 0)))
 (t 0)))

(define (hl_condition syl)
"(lh_condition syl)
Function to determine the need for extra target points between an H and an L
Returns: 1 - extra target required
         0 - no target required.
"
(if (>= printdebug  4)
    (begin (print "Entering HL_condition")))
(cond
 ((and (eq 0 (item.feat syl 'accented))
       (string-matches (next_accent_type syl)
           "\\(L\\*\\|L\\+H\\*\\|L\\+\\!H\\*\\|L\\*\\+H\\|L\\*\\+!H\\|L\\-\\|L\\-L\\%\\|L-H\\%\\)")
       (string-matches (last_accent_type syl)
               "\\(H\\*\\|L\\+H\\*\\|L\\*\\+H\\\\|\\!H\\*\\|L\\+\\!H\\*\\|L\\*\\+\\!H\\|\\%H\\)")
                       ;MDS: added !H's
       (eq 1 (last_accent syl))

       ;; fall faster! -MDS
       (<= 2 (next_accent syl))) 1)
 (t 0)))

(define (next_accent syl)
"(next_accent syl)
Wrapper for c++ func ff_next_accent.
Returns the number of the syllables to the next accent in the following format.
0 - no next accent
1 - next syllable
2 - next next syllable
etc..."
(if (>= printdebug  4)
    (begin (print "Entering next_accent")))
(cond
 ((eq 0 (next_accent_type syl)) 0)
 (t (+ (item.feat syl 'next_accent) 1))))

;; Fixed bug that crashed complex phrase tones. - MDS
;; Not sure how else to get a big number...
(define infinity (/ 1 0))

;; Modified to include current accent as well -MDS

(define (last_accent syl)
"(last_accent syl)
Wrapper for c++ func ff_last_accent.
Returns the number of the syllables to the previous accent in the following format.
0 - accent on current syllable
1 - prev syllable
2 - prev to prev syllable
etc...
infinity - no previous syllable"
(if (>= printdebug  4)
    (begin (print "Entering last_accent")))
(cond
 ((not (equal? "NONE" (item.feat syl 'tobi_accent))) 0)
 ((equal? 0 (last_accent_type syl)) infinity)
 (t (+  (item.feat syl 'last_accent) 1))))

(define (next_accent_type syl)
"(next_accent_type syl)
Returns the type of the next accent."
(cond
 ((not (eq 0 (item.feat syl "n.R:Intonation.daughter1.name")))
  (item.feat syl "n.R:Intonation.daughter1.name"))
 ((eq 0 (item.feat syl 'syl_out)) 0)  ;;GM real ip_final would be better
 (t (next_accent_type (item.relation.next syl 'Syllable)))))

(define (last_accent_type syl)
"(last_accent_type syl)
Returns the type of the last (previous)  accent."
(if (>= printdebug  4)
    (begin (print "Entering last_accent_type")))
(cond
  ((not (equal? "NONE"  (item.feat syl 'p.tobi_endtone)))
   (item.feat syl 'R:Syllable.p.tobi_endtone))
  ((not (equal? "NONE"  (item.feat syl 'p.tobi_accent)))
   (item.feat syl 'R:Syllable.p.tobi_accent))
  ((eq 0 (item.feat syl 'syl_in)) 0)  ;;GM real ip_initial would be better
  (t (last_accent_type (item.prev syl 'Syllable)))))

(define (next_accent_start syl)
"(next_accent_start syl)
Returns the start time  of the vowel of next accented syllable"
(if (>= printdebug 4)
    (begin (print "Entering next_accent_start")))
(cond
 ((not (eq 0 (item.feat syl "n.R:Intonation.daughter1.name")))
  (item.feat syl "R:Syllable.n.syllable_start")) ;;GM vowel start would be better
 ((eq 0 (item.feat syl 'syl_out)) 0)
 (t (next_accent_start (item.relation.next syl 'Syllable)))))

; new features (not used yet)

(define (ip_final syl)
  "(ip_final SYL)
  returns 1 if the syllable is the final syllable of an
  ip (intermediate phrase)"
  (cond
   ((or (equal? 0 (item.feat syl "syl_out"))
       (equal? "L-" (item.feat syl "tobi_endtone"))
       (equal? "H-" (item.feat syl "tobi_endtone"))
       (equal? "!H-" (item.feat syl "tobi_endtone"))) 1)
   (t 0)))

(define (ip_initial syl)
  "(ip_initial SYL)
  returns 1 if the syllable is the initial syllable of an
  ip (intermediate phrase)"
  (cond
   ((equal? 0 (item.feat syl "syl_in"))
    1)
   ((equal? 1 (ip_final (item.relation.prev syl 'Syllable)))
    1)
   (t 0)))

;; NEXT TWO FUNCTIONS ARE NEW - MDS
(define (ip_one_syllable_case syl)
  "(ip_one_syllable_case SYL)
  returns true if the syllable is the initial syllable of an
  ip (intermediate phrase) and doesn't itself contain a complex
  tone that starts opposite this syllable's accent"
  (if (eqv? 0 (ip_initial syl))
      0
      (let ((accent (item.feat syl "tobi_accent"))
        (tone (item.feat syl "tobi_endtone")))
    (cond
      ((and (equal? tone "L-H%")
        (or (equal? accent "H*")
            (equal? accent "!H*")
            (equal? accent "L+H*")
            (equal? accent "L+!H*")
            (equal? accent "L*+H")
            (equal? accent "L*+!H*")
            (equal? accent "H+!H*")))
       0)
      ((and (or (equal? tone "H-L%")
            (equal? tone "!H-L%"))
        (equal? accent "L*"))
       0)
      (t
       1)))))

(define (hstar_weak_target syl)
  (if (and (equal? 0 (item.feat syl 'asyl_in))
       (member (next_accent_type syl)
           (list "L*" "L*+H" "L*+!H" "L+H*" "L+!H*")))
      1
      0))

(provide 'tobi_rules)